home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / glass / glass.lha / GLASS / tm / tmgram.y < prev    next >
Text File  |  1990-11-02  |  6KB  |  283 lines
  1. %{
  2. /* file: tmgram.y
  3.    A YACC grammar for Miranda algebraic datatypes
  4.  */
  5.  
  6. #include "tmdefs.h"
  7. #include <ctype.h>
  8. #include <tmc.h>
  9.  
  10. #include "tmds.h"
  11. #include "tmstring.h"
  12. #include "debug.h"
  13. #include "tmerror.h"
  14. #include "tmglobal.h"
  15. #include "tmlex.h"
  16. #include "tmmisc.h"
  17.  
  18. extern void setlexfile();
  19.  
  20. #define YYDEBUG 1   /* allow compilation of debugging code */
  21.  
  22. ds_list ans;
  23.  
  24. %}
  25.  
  26. %union {
  27.     ds pards;
  28.     ds_list pardslist;
  29.     constructor parcons;
  30.     constructor_list parconslist;
  31.     field parfield;
  32.     field_list parfieldlist;
  33.     char *parstring;
  34. }
  35.  
  36. %token BAR
  37. %token COLCOLEQ
  38. %token EQEQ
  39. %token COLON
  40. %token COMMA
  41. %token <parstring> NAME
  42. %token SEMI
  43. %token LSBRAC
  44. %token RSBRAC
  45. %token LRBRAC
  46. %token RRBRAC
  47.  
  48. %start top
  49.  
  50. %type <pardslist> typelist
  51. %type <pards> type
  52. %type <parconslist> constructorlist
  53. %type <parcons> constructor
  54. %type <parfieldlist> tuplebody
  55. %type <parfieldlist> fieldlist
  56. %type <parfield> field
  57. %type <parstring> typename
  58. %type <parstring> consname
  59. %type <parstring> elmname
  60. %%
  61. top:
  62.       typelist                          { ans = $1;                          }
  63.  
  64. typelist:
  65.       /* empty */                       { $$ = new_ds_list();                }
  66.     | typelist type                     { app_ds_list( $1, $2 ); $$ = $1;    }
  67.     ;
  68.  
  69. type:
  70.       typename COLCOLEQ constructorlist SEMI
  71.     {
  72.         ckconstructor( $1, $3 );
  73.         $$ = new_DsCons( $1, $3 );
  74.     }
  75.     | typename EQEQ LRBRAC tuplebody RRBRAC SEMI
  76.     {
  77.         cktuple( $1, $4 );
  78.         $$ = new_DsTuple( $1, $4 );
  79.     }
  80.     | error SEMI
  81.     {
  82.         $$ = new_DsCons( new_string( "" ), new_constructor_list() );
  83.     }
  84.     ;
  85.  
  86. tuplebody:
  87.       field
  88.         {
  89.         $$ = new_field_list();
  90.         app_field_list( $$, $1 );
  91.     }
  92.     | tuplebody COMMA field
  93.         {
  94.         app_field_list( $1, $3 );
  95.         $$ = $1;
  96.     }
  97.     ;
  98.  
  99. constructorlist:
  100.       constructor
  101.       {
  102.           $$ = new_constructor_list();
  103.           app_constructor_list( $$, $1 );
  104.       }
  105.     | constructorlist BAR constructor
  106.       {
  107.           app_constructor_list($1, $3);
  108.           $$ = $1;
  109.       }
  110.     ;
  111.  
  112. constructor:
  113.       consname fieldlist
  114.       {
  115.           $$ = new_constructor($1, $2);
  116.       }
  117.     ;
  118.  
  119. fieldlist:
  120.       /* empty */                       { $$ = new_field_list();            }
  121.     | fieldlist field                   { app_field_list($1, $2); $$ = $1;  }
  122.     ;
  123.  
  124. field:
  125.       elmname COLON NAME                { $$ = new_field( 0, $1, $3 );       }
  126.     | elmname COLON LSBRAC NAME RSBRAC  { $$ = new_field( 1, $1, $4 );       }
  127.     ;
  128.  
  129. typename:
  130.       NAME                              { cktypename( $1 ); $$ = $1;         }
  131.     ;
  132.  
  133. consname:
  134.       NAME                              { ckconsname( $1 ); $$ = $1;         }
  135.     ;
  136.  
  137. elmname:
  138.       NAME                              { ckelmname( $1 ); $$ = $1;          }
  139.     ;
  140.  
  141. %%
  142.  
  143. static void yyerror( s )
  144.  char *s;
  145. {
  146.     s = s; /* to stop complaints about unused arguments */
  147.     (void) sprintf( errpos, "%s(%d)", dsfilename, dslineno );
  148.     error( SYNTAXERR );
  149. }
  150.  
  151. /* Check a name on underscores and give an error message if one is found */
  152. static void ckunderscore( s )
  153.  char *s;
  154. {
  155.     if( index( s, '_' ) != NULL ){
  156.     (void) sprintf( errpos, "%s(%d)", dsfilename, dslineno );
  157.     (void) strcpy( errarg, s );
  158.     error( NOUNDERSCORE );
  159.     }
  160. }
  161.  
  162. /* Ensure that name 's' is a proper constructor name. */
  163. static void ckconsname( s )
  164.  char *s;
  165. {
  166.     if( s[0] == '\0' ) return;
  167.     ckunderscore( s );
  168.     if( !isupper( s[0] ) ){
  169.     (void) sprintf( errpos, "%s(%d)", dsfilename, dslineno );
  170.     (void) strcpy( errarg, s );
  171.     error( BADCONSNM );
  172.     }
  173. }
  174.  
  175. /* Ensure that name 's' is a proper type name. */
  176. static void cktypename( s )
  177.  char *s;
  178. {
  179.     if( s[0] == '\0' ) return;
  180.     ckunderscore( s );
  181.     if( !islower( s[0] ) ){
  182.     (void) sprintf( errpos, "%s(%d)", dsfilename, dslineno );
  183.     (void) strcpy( errarg, s );
  184.     error( BADTYPENM );
  185.     }
  186. }
  187.  
  188. /* Ensure that name 's' is a proper element name. */
  189. static void ckelmname( s )
  190.  char *s;
  191. {
  192.     if( s[0] == '\0' ) return;
  193.     ckunderscore( s );
  194. }
  195.  
  196. /* Ensure that there are no double names in tuple with name 'nm'
  197.  * and fields 'fields'.
  198.  */
  199. static void cktuple( nm, fields )
  200.  string nm;
  201.  field_list fields;
  202. {
  203.     register unsigned int ix;    /* index of currently checked field */
  204.     register unsigned int iy;    /* index of searched subsequent fields */
  205.     field fx;            /* checked field */
  206.     field fy;            /* searched field */
  207.     string fnm;            /* name of currently checked field */
  208.  
  209.     for( ix=0; ix<fields->sz; ix++ ){
  210.     fx = fields->arr[ix];
  211.     fnm = fx->sename;
  212.     iy = ix+1;
  213.     for( iy=ix+1; iy<fields->sz; iy++ ){
  214.         fy = fields->arr[iy];
  215.         if( strcmp( fy->sename, fnm ) == 0 ){
  216.         (void) sprintf( errpos, "in type '%s'", nm );
  217.         (void) sprintf( errarg, "'%s'", fnm );
  218.         error( DOUBLEFIELD );
  219.         }
  220.     }
  221.     }
  222. }
  223.  
  224. /* Ensure that there are no double names in each of the constructors of
  225.  * constructor type with name 'nm' and constructors 'cons'.
  226.  */
  227. static void ckconstructor( nm, cons )
  228.  string nm;
  229.  constructor_list cons;
  230. {
  231.     constructor conx;
  232.     constructor cony;
  233.     field_list fields;
  234.     register unsigned int cix;    /* index in constructor list */
  235.     register unsigned int ix;    /* index of currently checked field */
  236.     register unsigned int six;    /* index for searching of fields/constr. */
  237.     field fx;            /* checked field */
  238.     field fy;            /* searched field */
  239.     string fnm;            /* name of currently checked field */
  240.     string connm;        /* name of current constructor */
  241.  
  242.     for( cix=0; cix<cons->sz; cix++ ){
  243.     conx = cons->arr[cix];
  244.     fields = conx->confields;
  245.     connm = conx->conname;
  246.     for( six=cix+1; six<cons->sz; six++ ){
  247.         cony = cons->arr[six];
  248.         if( strcmp( cony->conname, connm ) == 0 ){
  249.         (void) sprintf( errpos, "in type '%s'", nm );
  250.         (void) sprintf( errarg, "'%s'", connm );
  251.         error( DOUBLECONS );
  252.         }
  253.     }
  254.     for( ix=0; ix<fields->sz; ix++ ){
  255.         fx = fields->arr[ix];
  256.         fnm = fx->sename;
  257.         six = ix+1;
  258.         for( six=ix+1; six<fields->sz; six++ ){
  259.         fy = fields->arr[six];
  260.         if( strcmp( fy->sename, fnm ) == 0 ){
  261.             (void) sprintf(
  262.             errpos,
  263.             "in type '%s', constructor '%s'",
  264.             nm,
  265.             connm
  266.             );
  267.             (void) sprintf( errarg, "'%s'", fnm );
  268.             error( DOUBLEFIELD );
  269.         }
  270.         }
  271.     }
  272.     }
  273. }
  274.  
  275. /* top level of parser. */
  276. ds_list parse( f )
  277.  FILE *f;
  278. {
  279.     setlexfile( f );
  280.     (void) yyparse();
  281.     return( ans );
  282. }
  283.